perm filename GRINDE[MAC,LSP] blob
sn#404898 filedate 1978-12-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00015 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002
C00007 00003
C00010 00004
C00015 00005
C00018 00006
C00020 00007
C00023 00008
C00025 00009
C00029 00010
C00036 00011
C00042 00012
C00045 00013
C00050 00014
C00052 00015
C00055 ENDMK
C⊗;
;;; -*-LISP-*-
;;; **************************************************************
;;; ***** Maclisp ****** S-expression formatter (grindef) ********
;;; **************************************************************
;;; ** (c) Copyright 1978 Massachusetts Institute of Technology **
;;; ****** this is a read-only file! (all writes reserved) *******
;;; **************************************************************
;;;
;;; 09/21/74 maxpan made into 3 arg fn. third arg = m. /Eliminate
;;; excessive specbinding. grindpredict obtained via apply.
;;; 05/7/75 ? - Vertical-bars and exclamations slashed
;;; 06/14/75 jonl - Flushed remgrind. repaired ghash to work on dec-10
;;; 08/07/75 jonl - Flushed newio macroified stuff, and made dynamic
;;; 09/18/75 jonl - Fixed up a few newio goodies, and removed more grind
;;; stuff to gfile
;;; 10/10/75 jonl - Added mem-form property for fillarray
;;; 11/01/75 jonl - Fixed up the autoload properrty makers for slashify etc.
;;; 09/13/76 jonl - changed loading message for qio, removed "M" from
;;; toplevel setqs
;;; 05/25/78 jonl - Had GRINDEF and SPRINTER lambda-bind variable LINEL, and
;;; removed all references to CONNIVER and PLANNER stuff.
;;; Flush "SGPLOSES" and NOARGS calls; flush GBREAK.
;;; Change "NIL" into "()".
;;; 07/12/78 jonl - Fix up usages of LINEL by creating function GRLINEL,
;;; and install macros for POPL and REMSEMI-TAC
;;; 09/15/78 {hic?} - let "*" be returned instead of (ascii 0)
;;; 11/01/78 jonl - print loading message on MSGFILES instead of OUTFILES
;;; don't GRINDEF is atomic arg is not a SYMBOL
(declare (array* (notype (gtab/| 128.)))
(special merge readtable grindreadtable remsemi outfiles
grindpredict grindproperties grindef predict
grindfn grindmacro programspace topwidth niop/|
grindlinct global-lincnt /; /;/; user-paging arg
chrct linel pagewidth gap comspace fill nomerge
/;/;? ↑d macro unbnd-vrbl form comnt
n m l h grind-standard-quote prog?)
(*expr form topwidth programspace pagewidth comspace
nomerge remsemi)
(*fexpr trace slashify unslashify grindfn grindmacro
unreadmacro readmacro grindef)
(*lexpr merge predict user-paging fill testl)
(and (status nofeature newio) (*lexpr linel))
(mapex t)
(genprefix /|gr)
(fixnum nn mm
(prog-predict notype fixnum fixnum)
(block-predict notype fixnum fixnum)
(setq-predict notype fixnum fixnum)
(panmax notype fixnum fixnum)
(maxpan notype fixnum fixnum)
(gflatsize) (grchrct) (grlinel)))
(defun macex macro (x)
(list 'defun
(cadr x)
'macro
(caddr x)
(eval (cadddr x))))
(defun remsemi-tac macro (x) '(and remsemi (remsemi))) ;REMSEMI - test and call
(defun popl macro (x) '(progn (pop l) (remsemi-tac) l))
(macex newlineseq (x)
(cond ((status feature multics)
''(list (ascii 10.)))
(t ''(list (ascii 13.) (ascii 10.)))))
(macex ghash (x)
(cond ((status feature multics)
'(prog2 (rplaca x
(subst (cadr x)
'data
'(cond ((atom data) (abs (sxhash data)))
((maknum data)))))
x))
('(prog2 (rplaca x 'maknum) x))))
(macex version (x)
(subst (maknam (nconc (newlineseq)
(explodec '|;Loading Grindef |)
(explodec (cond ((status feature newio)
(caddr (truename infile)))
((cadr (status uread)))
('/416)))
(newlineseq)))
'version
''(or (status feature noldmsg)
(prog2 (princ 'version msgfiles) '*))))
(version)
(prog () ;some initializations
(and (not (boundp 'grind-use-original-readtable))
(setq grind-use-original-readtable t))
(setq niop/| (status feature newio))
(and (not (boundp 'grind-standard-quote)) ;standard readmacroinverter for quote. "quote"
(setq grind-standard-quote t)) ;have your own macro for quote take effect, set
(setq remsemi () ;grind-standard-quote to ().
grindlinct 8.
grindef ()
global-lincnt 59.
grindproperties '(expr fexpr value macro))
(array gtab/| t 128.))
(defun grindef fexpr (atoms)
((lambda (linel) ;(grindef <atoms>) grinds the properties
(prog (traced fn props) ;of the atoms listed on
(cond (atoms (setq grindef atoms)) ;"grindproperties". (grindef
((setq atoms grindef))) ;(additional properties) <atoms>) grinds
(setq props grindproperties) ;the additional properties as well.
a (cond ((null atoms) (return '*)))
(setq fn (car atoms) atoms (cdr atoms))
(cond ((atom fn) (and (not (symbolp fn)) (go a)))
((setq props (append fn props)) (go a)))
(cond ((setq traced (and (status feature trace)
(memq fn (trace)))) ;flag for fn being traced
(terpri)
(terpri)
(princ '/;traced)))
(do
((plist (plist fn) (cddr plist))
(ind 'value (car plist))
(prop (and (boundp fn) (cons () (eval fn)))
(cadr plist))
(valueless () t)) ;needed in case there are value properties
(())
(cond ((and traced
(memq ind '(expr fexpr macro))) ;ignore all but last if traced
(setq traced (get (cdr plist) ind))
(go b))
((not (memq ind props)) (go b)) ;grindef only desired properties.
((eq ind 'value)
(cond ((and prop (not valueless))
(terpri)
(terpri)
(sprint (list 'setq
fn
(list 'quote
(cdr prop)))
linel
0.)))
(go b)))
(terpri)
(terpri) ;terpri's placed here to avoid
(cond ((and (memq ind '(expr fexpr macro)) ;lambda -> defun
(eq (car prop) 'lambda))
(sprint (cons 'defun
(cons fn
(cond ((eq ind 'expr)
(cdr prop))
((cons ind
(cdr prop))))))
linel
0.))
((sprint (list 'defprop fn prop ind)
linel
0.)))
b
(or plist (return ()))) ;exit from do when no more properties
(go a))) ;look for more atoms to do.
(grlinel)
))
(defun unformat fexpr (x) ;(unformat fn1 fn2 ...) or (unformat
(or (atom (car x)) (setq x (car x))) ;(fn1 fn2 ...))
(mapc '(lambda (x) (remprop x 'grindfn)
(remprop x 'grindmacro)
(remprop x 'grindpredict))
x))
(defun grindmacro fexpr (y) ;eg (grindmacro quote /')
(putgrind (car y) (cdr y) 'grindmacro))
(defun grindfn fexpr (y) ;eg (grindfn (prog thprog) prog-form)
(putgrind (car y) (cdr y) 'grindfn))
(defun putgrind expr (fn prop ind) ;like putprop
(cond ((atom fn)
(setq prop
(cond ((atom (car prop))
(and (get (car prop) 'grindpredict)
(putprop fn
(get (car prop)
'grindpredict)
'grindpredict))
(car prop))
(t (and (eq (caar prop)
'readmacroinverse)
(putprop fn
(get 'readmacroinverse
'grindpredict)
'grindpredict))
(cons 'lambda (cons () prop)))))
(putprop fn prop ind))
((mapc '(lambda (x) (putgrind x prop ind)) fn))))
(defun readmacro fexpr (y) ;eg (readmacro quote /' [optional])
(putgrind (car y) ;where optional means macro cons not
(list (cons 'readmacroinverse ;list
(cons (cadr y) (cddr y))))
'grindmacro))
(defun unreadmacro fexpr (y) (remprop y 'grindmacro))
(defun grindmacrocheck (x l)
(cond ((or (atom x) (cdr x)) ())
((null (car x)) (= (length l) 2.)) ;x = (())
((equal (car x) '(t)) (cdr l)))) ;x = ((t))
(defun readmacroinverse fexpr (x) ;(fn l)--><macro char><pretty-print l>.
(prog (sprarg)
(cond ((grindmacrocheck (list (cdr x)) l) ;macro-char = atom or list of ascii
(cond ((atom (car x)) (princ (car x))) ;values. macro must have arg to execute
((mapc 'tyo (car x)))) ;inverse
(setq sprarg (cond ((null (cdr x)) (cadr l))
((eq (cadr x) t) (cdr l))
((= (length (cdr l)) 1.)
(cond ((null (cadr l))
(tyo 32.)
(return t))
(t (cadr l))))
(t (cdr l))))
(cond ((sprint1 sprarg (grchrct) m)
(prin1 sprarg)))
(return t))
(t (return ())))))
(defun lambda-form ()
(form 'line) ;format for lambda's
(and (< (grchrct) (gflatsize (testl))) ;prohibits form3 if args do not fit on
(setq form 'form2)) ;line.
(form 'block))
(defun prog-form ()
(form 'line) ;format for thprog's and prog's
(setq prog? t)
(setq form (cond ((and predict
(< (grchrct) (gflatsize (testl)))) ;prohibits form3 if args do not fit on
'form2) ;line.
(arg)))
(form 'block))
(defun if-form ()
(setq prog? t)
(form 'line)
(cond ((atom (testl)) (form 'line)))
(setq form (cond ((and predict
(< (grchrct) (gflatsize (testl))))
'form2)
(arg)))
(form 'list))
(defun def-form ()
(prog ()
(cond ((eq (car l) 'cdefun) (setq prog? t)))
(form 'line)
(form 'line)
go (cond ((memq (testl) '(expr fexpr macro))
(form 'line)
(go go)))
(setq form (cond ((and predict
(< (grchrct) (gflatsize (testl)))) ;prohibits form3 if args do not fit on
'form2) ;line.
(arg)))
(return (form 'block))))
(defun comment-form () (gblock (- (grchrct) 1. (gflatsize (car l))))) ;grinds l with args outputed as list.
(defun block-form () (gblock (grchrct)))
(defun mem-form ()
(prog (p gm)
(form 'line) ;quoted second arg ground as block
(remsemi-tac)
(catch (and (setq p (panmax (car l) (grchrct) 0.))
(cond ((< (panmax (car l) n 0.) p))
((setq n (grchrct))))))
(cond ((sprint1 (car l) n 0.) (prin1 (car l))))
a (cond ((null (cdr l))
(setq l
(error 'mem-form l 'fail-act))
(go a)))
(popl)
go (indent-to n)
(setq m (1+ m))
(cond ((eq (caar l) 'quote)
(princ '/')
(cond ((pprin (cadar l) 'block))
((prin1 (cadar l)))))
((setq gm (sprint1 (car l) n m))
(prin1 (car l))))
(popl)
(cond (l (go go)) ((return ())))))
(defun setq-form ()
(cond ((catch (prog (mm)
(setq mm (maxpan (cdr l) arg m)) ;standard form
(setq n arg) ;committed to at least standard form
(defprop setq setq-predict grindpredict) ;prediction in special form computed to
(and (< mm ;compare to p.
(panmax l
(prog2 ()
(1+ n)
(setq n arg))
m)) ;setq form
(return t))
(form 'line)
d (or l (return ()))
(indent-to n)
(form 'line)
(form 'code)
(remsemi-tac)
(go d)))
(defprop setq () grindpredict) ;setq-predict causes throw when variable
(form 'line) ;name is very long. therefore, it is
(setq form n)))) ;not used all the time but only inside
;setq-form.
(declare (unspecial l n m))
(defun setq-predict (l n m) ;returns number of lines to print args
(prog (mm nn) ;as name-value pairs.
(setq n (- n 2. (gflatsize (car l)))) ;n = space for name<space>value. 2 =
(setq mm 0.) ;space for ( and <space preceding
a (and (null (setq l (cdr l))) (return mm)) ;variable>.
(and (semi? (car l)) (go a))
(setq nn (- n 2. (gflatsize (car l)))) ;nn = space for value. 2 = space for )
b (cond ((null (cdr l)) ;and <space preceding value>.
(setq l (error 'setq-predict
l
'wrng-no-args))
(go b)))
(setq l (cdr l))
(and (semi? (car l)) (go b))
(setq mm (+ mm (panmax (car l) nn 0.)))
(go a)))
(declare (special l n m))
;;;format control
(defun predict args (setq predict (cond ((= args 0.)) ((arg 1.))))) ;(predict) <=> (predict t) => super-careful
;sprint considering all formats. (predict ())
;=> less careful but quicker.
(defun programspace (x)
(setq programspace (setq linel x))
(setq comspace (- pagewidth gap programspace)))
(defun pagewidth (w x y z)
(setq pagewidth w)
(setq gap y)
(setq programspace (setq linel x))
(setq comspace z))
(defun comspace (x)
(setq comspace x)
(setq programspace (setq linel (- pagewidth gap comspace))))
(defun page () (tyo 12.) (setq grindlinct global-lincnt))
(defun fill args (setq fill (cond ((= args 0.)) ((arg 1.))))) ;(fill) <=> (fill t) => spaces gobbled in ;
;comments. (fill ()) => spaces not gobbled.
;triple semi comments are never filled but are
;retyped exactly inuser's original form.
(defun merge args (setq merge (cond ((= args 0.)) ((arg 1.))))) ;(merge) <=> (merge t) => adjoining ; and ;;
;comments are merged. (merge ()) => adjoining
;comments not merged. ;;;... are never merged.
(defun user-paging args ;(user-paging) <=> (user-paging t)
(setq user-paging (cond ((= args 0.)) ((arg 1.))))) ;grind does not insert any formfeeds, but
;preserves paging of user's file. (user-paging
;() ) => grind inserts formfeed every 59 lines.
;attempts to avoid s-expr pretty-printed over
;page boundary. ignores users paging. paging of
;user's file.
(defun topwidth (x) (setq topwidth x))
(defun remsemi () ;REMSEMI must be non-()
(do ((fl))
((cond ((rem/;) (rem/;/;) (setq fl t) ())
((rem/;/;) (setq fl t) ())
(t))
fl)))
(defun semisemi? (k)
(cond ((null remsemi) ()) ;check for any ;;'s
((eq k /;/;))
((atom k) ())
((or (semisemi? (car k)) (semisemi? (cdr k)))))) ;at any depth
(defun semi? (k) (and remsemi (or (eq (car k) /;) (eq (car k) /;/;))))
(defun indent (nn) ;indents additonal nn spaces.
(cond ((minusp (setq nn (- (grchrct) nn)))
(error 'indent/ beyond/ linel?
nn
'fail-act)
(terpri))
((indent-to nn))))
(defun stat-tab macro (x) (list 'quote (status tabsize))) ;replaced by compiler by tab (8 its, 10.
;;multics)
(defun indent-to (nn) ;chrct set to nn
((lambda (nct tab)
(declare (fixnum nct tab))
(cond ((or (< nct 0.) (> nn nct)) ;chrct may become negative from
(turpri) ;prin50com.
(setq nct linel)))
(cond ((< nn nct) ;some indentation is necessary
(setq tab (+ nct
(- (stat-tab))
(\ (- linel nct) (stat-tab)))) ;position as a result of first tab.
(cond ((< tab nn) (grindslew (- nct nn) 32.)) ;tabs do not move 8, but
((tyo 9.) ;to nearest multiple of 8
(setq nct tab)
(cond ((< nn nct)
(grindslew (// (setq nct
(- nct nn))
(stat-tab))
9.)
(grindslew (\ nct (stat-tab))
32.))))))))
(grchrct)
0.))
(defun grindslew (nn x) (do mm nn (1- mm) (zerop mm) (tyo x)))
(defun pprin (l tp)
(setq /;/;? ()) ;this global variable records whether the last
(cond ;form printed was a double-semi comment. if so,
((atom l) (prin1 l) t) ;it is non-() and rem/;/; merges the current
;comment. this meging should not happen across
;a pprin. furthermore, it is a bug if pprin is
((eq tp 'line) (cond ((gprin1 l n) (prin1 l))) t) ;printing code that is an atom. then /;/;? is
((eq tp 'block) ;not set to () and it falsely indicates tha the
(or (and (atom (car l)) ;last form printed was a /;/; comment. l is
((lambda (x) (and x (apply x ()))) ;ground as line if tp = 'line, as a block if tp
(get (car l) 'grindmacro))) ;= 'block or as a function followed by a list
(progn (princ '/() ;of arguments if l = 'list, or normally
(gblock (grchrct)) ;if tp = 'code.
(princ '/)))))
((eq tp 'list)
(or (and (atom (car l))
((lambda (x) (and x (apply x ())))
(get (car l) 'grindmacro)))
(progn (princ '/()
(gblock (- (grchrct) 1. (gflatsize (car l))))
(princ '/)))))
((eq tp 'code) (sprint1 l (grchrct) m) t)))
(defun turpri ()
(and remsemi comnt (prin50com)) ;cr with line of outstanding single semi
(terpri) ;comment printed, if any. grindlinct =
(setq grindlinct (cond ((= grindlinct 0.) global-lincnt) ;lines remaining on page.
((1- grindlinct)))))
(defun grchrct ()
(cond (niop/| (- linel (charpos (car (or (and ↑R outfiles) '(T))))))
(chrct)))
(defun grlinel ()
(cond (niop/| (linel (car (or (and ↑R outfiles) '(T)) )))
(linel)))
(defun testl args
(prog (k nargs)
(setq k l nargs (cond ((= 0. args) 0.) ((arg 1.))))
a (cond ((null k) (return ()))
((semi? (car k)) (setq k (cdr k)) (go a))
((= 0. nargs)
(return (cond ((= 2. args) k) (t (car k)))))
((setq nargs (1- nargs))
(setq k (cdr k))
(go a)))))
(defun form (x) ;pprin the car of l, then pops l.
(cond ((remsemi-tac) (form x)) ;no-op if l is already (). process
(l (cond ((pprin (car l) x) ;initial semi-colon comment, if any,
(and (cdr l) (tyo 32.)) ;then try again. pretty-print c(car l)
(setq l (cdr l)))
(t (prin1 (car l))
(and (cdr l) (tyo 32.))
(setq l (cdr l))))))) ;in desired format. if l is not yet (), output
;a space. return popped l.
(defun sprinter (l) ;pretty print over whole width
((lambda (linel)
(turpri)
(turpri)
(sprint l linel 0.)
(turpri)
'*)
(grlinel)))
(defun sprint (l n m)
(fillarray 'gtab/| '(()))
(sprint1 l n m))
;;;sprint formats
;;;form1 = (s1 form2 = (s1 s2 form3 = (s1 s2 (sprint1 last))
;;; s2 s3)
;;; s3)
(defun sprint1 (l n m) ;expression l to be sprinted in space n
(prog (form arg fn args p prog? grindfn form3? gm) ;with m unbalanced "/)" hanging. p is
(and (remsemi-tac) (null l) (return ())) ;number lines to sprint1 as form2
(setq /;/;? ())
(indent-to n)
(cond ((atom l) (prin1 l) (return ())))
(cond ((and grind-standard-quote ;this is an explicit check for quote.
(eq (car l) 'quote) ;the alternative is to use the standard
(cdr l) ;grindmacro to use your own personal readmacro
(null (cddr l))) ;for quote, setq grind-standard-quote to ().
(princ '/')
(setq gm (sprint1 (cadr l) (grchrct) m))
(return ())))
(and (atom (car l))
(setq fn (car l))
((lambda (x) (and x (apply x ())))
(get (car l) 'grindmacro))
(return ()))
(cond ((semisemi? l)) ;if a ;; comnt, force multi-line
((< (+ m -1. (gflatsize l)) (grchrct))
(return (gprin1 l n))))
(princ '/()
(setq n (grchrct))
(setq arg (- n (gflatsize (car l)) 1.))
(and
(atom (setq args
(cond ((setq grindfn (get fn
'grindfn))
(apply grindfn ())
(and (numberp form)
(setq n form)
(go b))
(and (null l)
(princ '/))
(return ()))
l)
((cdr l)))))
(go b))
(catch ;catch exited if space insufficient.
(and
(setq p (maxpan args arg m)) ;p = # of lines to sprint l in standard
(cond (predict (not (< (maxpan args n m) p))) ;format. exit if miser more efficient
(fn)) ;than standard in no-predict mode, use
(setq n arg) ;miser format on all non-fn-lists.
(cond ;committed to standard format.
(grindfn (or (eq form 'form2)
(> (maxpan args (grchrct) m) p)
(setq n (grchrct))))
((prog ()
(or predict (go a)) ;skip form3 is predict=().
(catch
(setq
form3? ;l cannot be fit in chrct is it more
(and (not (eq (car (last l)) /;)) ;efficient to grind l form3 or form2
(< (maxpan (last l)
(- (grchrct)
(- (gflatsize l)
(gflatsize (last l))))
m)
p))))
a (cond ((setq gm (gprin1 (car l) n))
(cond ((grindmacrocheck gm l)
(princ '/./ )
(gprin1 l (- n 2.))
(setq l ())
(go b1))
(t (prin1 (car l))))))
(tyo 32.)
(and (cdr (setq l (cdr l))) form3? (go a))
b1 (setq n (grchrct)))))))
b (grindargs l n m)))
(defun grindargs (l nn mm) ;elements of l are ground one under the
(prog (gm sprarg1 sprarg2) ;next
a (and (done? nn) (return ())) ;prints closing paren if done.
(setq sprarg1
(cond ((and prog?
(car l)
(atom (car l)))
(+ nn 5.)) ;exception of tags which are unindented
(nn))) ;5
(setq sprarg2 (cond ((null (cdr l)) (1+ mm))
((atom (cdr l))
(+ 4. mm (gflatsize (cdr l))))
(0.)))
(cond ((setq gm (sprint1 (car l) sprarg1 sprarg2))
(cond ((grindmacrocheck gm l)
(princ '/./ )
(sprint1 l (- sprarg1 2.) sprarg2)
(setq l ())
(go a))
(t (prin1 (car l))))))
(setq l (cdr l))
(go a)))
(defun done? (nn)
(cond ((atom l)
(and /;/;? (indent-to nn)) ;if previous line a ;; comment, then do
(cond (l (princ '/ /./ ) (prin1 l))) ;not print closing paren on same line as
(princ '/)) ;comment.
t))) ;prints closing "/)" if done
(defun gblock (n) ;l printed as text with indent n.
(prog (gm)
(and (remsemi-tac) (or l (return ())))
a (cond ((setq gm (gprin1 (car l) n))
(cond ((grindmacrocheck gm l)
(princ '/./ )
(gprin1 l (- n 2.))
(return (setq l ())))
(t (prin1 (car l))))))
(or (popl) (return ()))
(cond ((< (gflatsize (car l)) (- (grchrct) 2. m))
(tyo 32.)
(go a))
((and (not (atom (car l))) ;non-atomic elements occuring in block
(< (- n m) (gflatsize (car l)))) ;too large for the line are sprinted.
(cond ((setq gm (sprint1 (car l) n m)) ;this occurs in the variable list of a
(cond ((grindmacrocheck gm l) ;thprog.
(princ '/./ )
(sprint1 l (- n 2.) m)
(return (setq l ())))
(t (prin1 (car l))))))
(or (popl) (return ()))))
(indent-to n) ;new line
(go a)))
(defun gprin1 (l nn) ;prin1 with grindmacro feature.
(cond ((atom l) (prin1 l) ())
((prog (gm)
(remsemi-tac)
(and (atom (car l))
((lambda (x) (and x (apply x ())))
(get (car l) 'grindmacro))
(return ()))
(princ '/()
a (cond ((setq gm (gprin1 (car l) nn))
(cond ((grindmacrocheck gm l)
(princ '/./ )
(gprin1 l (- nn 2.))
(setq l ())
(go a1))
(t (prin1 (car l))))))
(popl)
a1 (and (done? nn) (return ()))
(tyo 32.)
(go a)))))
;;prediction functions
(declare (unspecial l n m))
;;;for increased speed, l n m are made unspecial in maxpan and panmax
(defun maxpan (l n m)
(declare (fixnum g))
(prog (g) ;estimates number of lines to sprint1
(setq g 0.) ;list of s expression one under the next
a (setq g
(+ g ;in space n
(panmax (car l)
n
(cond ((null (setq l (cdr l))) (1+ m))
((atom l) (+ m 4. (gflatsize l)))
(0.)))))
(and (atom l) (return g))
(go a)))
(defun panmax (l n m)
(cond ((< (+ m -1. (gflatsize l)) n) 1.) ;estimates number of lines to sprint1 an
((or (< n 3.) (atom l)) (throw 40.)) ;s expression in space n. less costly
((or (not (atom (car l))) (atom (cdr l))) ;than sprint as prediction always chooses form2.
(maxpan l (sub1 n) m)) ; if insufficient space, throws.
(((lambda (x) (and x (funcall x l n m)))
(get (car l) 'grindpredict)))
((maxpan (cdr l) (- n 2. (gflatsize (car l))) m))))
(defun prog-predict (l n m)
((lambda (nn) (+ (block-predict (cadr l) nn 1.)
(maxpan (cddr l) nn m)))
(- n 2. (gflatsize (car l)))))
(defprop lambda-form prog-predict grindpredict)
(defprop prog-form prog-predict grindpredict)
(defun block-predict (l n indent) ;indent=spaces indented to margin of
(cond ((> 1. (setq n (- n indent))) (throw 50.)) ;block. throw if insuff remaining space.
((1+ (// (- (gflatsize l) indent) n))))) ;number of lines approx by dividing size of l by
;block width.
(defun block-predictor (l n m) (block-predict l n 1.)) ;m not used.
(defprop block-form block-predictor grindpredict)
(defun comment-predict (l n m) ;m not used by block-predict. third arg
(block-predict l n (+ (gflatsize (car l)) 2.))) ;represents indentation of block.
(defprop comment-form comment-predict grindpredict)
(defun readmacroinverse-predict (l n m) (panmax (cadr l) (1- n) m))
(defprop readmacroinverse readmacroinverse-predict grindpredict)
(declare (special l n m))
(defun slashify fexpr (chars) (mapc 'slashify1 chars)) ;(eg (slashify $)). preserve slashes preceding
;user read macros.
(defun unslashify fexpr (chars) (mapc 'unslashify1 chars))
(defun slashify1 (char) ;make char '-like readmacro.
((lambda (readtable)
(or (null (getchar char 2.)) ;will be null only if char is single
(setq char (error 'slashify
char
'wrng-type-arg)))
(setsyntax char
'macro
(subst char
'char
'(lambda () (list 'char
(read)))))
(apply 'readmacro (list char char)))
grindreadtable))
(defun unslashify1 (char)
((lambda (readtable) (or (null (getchar char 2.))
(setq char
(error 'unslashify
char
'wrng-type-arg)))
(setsyntax char 'macro ())
(apply 'unreadmacro (list char)))
grindreadtable))
(defun gflatsize (data)
((lambda (nn bucket)
(setq bucket (gtab/| nn))
(cdr (cond ((and bucket (assq data bucket)))
(t (car (store (gtab/| nn)
(cons (setq data
(cons data
(flatsize data)))
bucket)))))))
(\ (ghash data) 127.)
()))
;;default formats
(readmacro quote /') ;still need to define the standard macro
(grindfn (grindfn grindmacro) (form 'line)
(form 'block))
(grindfn lambda lambda-form)
(grindfn (if-added if-needed if-removed) if-form)
(grindfn (defun cdefun macex) def-form)
(grindfn prog prog-form)
(grindfn (comment remob **array *fexpr *expr *lexpr special unspecial fixnum flonum) comment-form)
(grindfn (member memq map maplist mapcar mapcon mapcan mapc assq
assoc sassq sassoc getl fillarray) mem-form)
(grindfn setq setq-form)
(grindfn csetq setq-form)
(predict ())
;;;the following default formats are relevant only to grinding files.
;;;however, they appear here since the format fns are not defined
;;;in gfile and gfn is not loaded until after gfile.
;;default formats
(pagewidth 112. 70. 1. 41.)
(topwidth 110.)
(merge t)
(fill t)
(user-paging ())
((lambda (m)
(and (or (not (boundp 'grindreadtable))
(null grindreadtable))
((lambda (readtable) (setsyntax 12. 'single ()) ;↑l made noticeable.
(and niop/| (sstatus terpri t)) ;the grindreadtable is tailored for
(setsyntax '/; ;grind. no auto cr.
'splicing
'semi-comment)) ;are inserted by lisp when
(setq grindreadtable
(*array ()
'readtable
grind-use-original-readtable))))
(cond ((or m (status feature dec10))
(prog (form ↑w h l) ;loader for grind (init) file
(setq h (list ()) l (crunit))
(apply 'crunit (list 'dsk (status udir)))
(cond ((apply 'uprobe (setq m (cond (m '(grind /(init/))) ('(grind ini)))))
(terpri)
(apply 'uread m)
(and (not (status feature noldmsg))
(princ '/;loading/ dsk/:)
(cond ((eq (cadr m) 'ini)
(princ 'grind/.ini/[)
(princ (caadr (crunit)))
(princ '/,)
(princ (cadadr (crunit)))
(princ '/]/ ))
(t (princ (cadr (crunit)))
(princ '/;)
(princ 'grind/ /(init/)/ ))))
(setq ↑q t))
(t (go l)))
ini (cond ((and ↑q (not (eq h (setq form (read h)))))
(eval form)
(go ini)))
l (apply 'crunit l)
(gctwa)
(return '*)))
(t (errset (load (list (status udir) ;loader for start←up.grind file
'start←up
'grind))
()))))
(status feature its))
(sstatus feature grindef)
βββ